home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
pascal
/
tbase601.zip
/
TBDEMO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-12-18
|
8KB
|
277 lines
Program TbDemo;
(*=============================================================================
+ This Demo demonstrates the features of Tbase3 along with DbDate and DbStr +
*
+============================================================================*)
Uses Crt, Tbase, DbDate, DbStr;
Var Ch : Char ; { A Spare one to read any key }
Opt : INTEGER ;
Procedure MemCheck;
(*======================================*
* Checks the proper memory allocation *
* and deallocation. *
*=======================================*)
Var MyDb : DataObject;
Mv : LongInt ;
Begin
ClrScr ;
Mv := MemAvail ;
Writeln('Memory available Before Opening Dbase file :' , MemAvail);
New( MyDb , Init('DbStr.Dbf') );
Writeln('Memory available After Opening Dbase File :' , MemAvail);
Writeln('Memory used for opening ''DbStr.Dbf'' file :' , Mv-Memavail);
Dispose( MyDb , done ) ;
Writeln('Memory After closing Dbase File with Done :' , MemAvail );
Writeln; Writeln(' Any key now...');
ch := Readkey ;
End;
Procedure CreateAndAdd ;
(*=======================================================
* Create a Dbase file and add some fields. *
* No need to go to Dbase III or FoxPro for this *
*======================================================*)
Var MyDb : DataObject ;
Begin
Clrscr;
Writeln( ' Creating a Dbase File Demo.Dbf now...', #10#10);
CreateDbFile('Demo.Dbf'); { This is NOT part of Object. }
{ Does not check for existing file. }
{ Be careful.. Next version will check }
Writeln(' Now you should open the file to manipulate..');
New( MyDb , Init('Demo.Dbf') ); { Open the file now.. One field is there }
{ With the name 'NEWFIELD','C' , 10 ,0 }
With MyDb^ do
Begin
Writeln(' Displayig the field in the fresh Dbase file..', #10#10);
DisplayFields; { Just see the fields }
Writeln(' Changing and Adding field now.. and listing again..',#10);
ChangeField('NewField','Cust_no', 'N',6,0 ) ; { Change the first Field}
AddField('Cust_Name','C',20,0); { One more field }
AddField('Cust_Addr','C',20,0); { Ok.. One more }
AddField('Date' , 'D', 100 , 0 ); { A date field.. Note that Field length }
{ and decimals are ignored and put its own.}
{ But you give it for the sake of argumant }
Addfield('BlaBla', 'K' , 10,0 ) ; { A wrong info.. This will be ignored }
{ With the Bleep and Dberror = 15 set }
{ Dberror = 15 - Invalid Field }
Writeln;
Write( '*Error* -', LastDbError ); { Just calling to clear the error. Otherwise,
All the rest calls are ignored }
Writeln( '- Invalid Field Type **** Due to the deliberate mistake ' );writeln;
DisplayFields; { Now we will see what happened }
End;
Dispose(MyDb, Done ); { Happy!! Close it then ! }
Writeln;
Writeln( ' Any key now..');
ch := Readkey;
End;
Procedure AddData;
(*=====================================================
* Adding some data to field.. Deleting.. packing *
* Recalling.. Note that Any Screen Comfort is NOT *
* Provided by Tbase3 yet. Next versions may have *
* some if Users want in Text Mode. *
* But a Graphical Input Object is underway *
*====================================================*)
Var MyDb : DataObject ;
Sysday : Date ; { Dbdate features also included }
i : longint;
DateField : String ; { Str8 is enough }
hh , mm , ss, s100 : Word ;
h1,m1,s1,s101 : Word ;
Begin
If not FileExists('Demo.Dbf') then
Begin
Warnerror(1) ;
Writeln(#10#10, ' Demo.Dbf is not yet created to Open.. ');
Writeln(' Try Option 2 first to create Demo.Dbf..');
Writeln(' Any key now..');
Ch := Readkey ;
Exit;
End;
Clrscr;
Today( Sysday ) ; { Get the System Date- DBdate.TPU }
Writeln(' Opening a Demo.Dbf again ');
New( MyDb , Init('Demo.Dbf') );
Writeln('Adding 1000 records With Random Data....');
For i := 1 to 1000 do With MyDb^ do
Begin
ClearMemRec; { Clear the memory rec to avoid Garbage data}
Replace('Cust_Name' , 'Nasir' + Cstr( i, 4, 0) );
{ Data is Nasir0001 to Nasir1000 }
{ Notice the field name is used to replace }
Replace('Cust_Addr', 'Sri Lanka Only' );
Replace('Cust_no', Cstr(i,6,0) ); { Replace Only Accept String}
{ Even if it is Numeric }
{ Use ReplNum for numeric }
DateAfter( SysDay , 1 ) ; { Add one by one to sysday }
DateField := DateToFormat( SysDay ); { Prepare for Replace }
{ Wrong date are ignored by check }
Replace('Date' , dateField ); (* Replace now accepts Format *)
AddDbRec; { Finally Add it to file }
End;
Dispose( myDb, Done );
Writeln;
Writeln( ' Any key now..');
Ch := Readkey;
End;
Procedure DeleteTest;
Var MyDb: DataObject;
i : longInt;
Begin
If not FileExists('Demo.Dbf') then
Begin
Warnerror(1) ;
Writeln(#10#10, ' Demo.Dbf is not yet created to Open.. ');
Writeln(' Try Option 2 first to create Demo.Dbf..');
Writeln(' Any key now..');
Ch := Readkey ;
Exit;
End;
New( MyDb , Init('Demo.Dbf') );
Writeln('Deleting Even numbered records...');
For i := 1 to 500 do with MyDb^ do
Begin
GetDbRec( i*2 );
DbDelete; { No need to rewrite as Autosave is ON- Default}
End;
Dispose( MyDb , Done );
Writeln;
Writeln( ' Any key now..');
Ch := Readkey;
End;
Procedure PackTest;
Var MyDb : DataObject;
Begin
If not FileExists('Demo.Dbf') then
Begin
Warnerror(1) ;
Writeln(#10#10, ' Demo.Dbf is not yet created to Open.. ');
Writeln(' Try Option 2 first to create Demo.Dbf..');
Writeln(' Any key now..');
Ch := Readkey ;
Exit;
End;
New( MyDb , Init('Demo.Dbf') );
Writeln( ' Packing Demo.Dbf..... ' );
MyDb^.Pack ; { Pack them }
Dispose( MyDb , Done );
Writeln;
Writeln( ' Any key now..');
Ch := Readkey;
End;
Procedure ZapTest;
(*==================================================*
* Zaps the Demo.Dbf *
*==================================================*)
Var MyDb : DataObject ;
Begin
If not FileExists('Demo.Dbf') then
Begin
Warnerror(1) ;
Writeln(#10#10, ' Demo.Dbf is not yet created to Open.. ');
Writeln(' Try Option 2 first to create Demo.Dbf..');
Writeln(' Any key now..');
Ch := Readkey ;
Exit;
End;
New( MyDb , Init('Demo.Dbf') );
Clrscr;
Writeln( ' Zapping the Demo.Dbf... ');
With MyDb^ do
Begin
Zap; { That's it!!! }
Writeln('Number of Records now is :' , RecCount :10 );
End;
Dispose( MyDb , done );
Writeln;
Writeln(' Any Key Now..');
ch := Readkey
End;
Procedure RecoverTest;
(*==================================================*
* TRIES to Recover as much *
* as Possible. No Guarantee Whatsoever is given *
* But, I have a Feeling that the First cluster *
* of the file will be protected forever.. *
*==================================================*)
Var MyDb : DataObject ;
Begin
If not FileExists('Demo.Dbf') then
Begin
Warnerror(1) ;
Writeln(#10#10, ' Demo.Dbf is not yet created to Open.. ');
Writeln(' Try Option 2 first to create Demo.Dbf..');
Writeln(' Any key now..');
Ch := Readkey ;
Exit;
End;
Clrscr;
New(myDb , Init('Demo.Dbf') );
Writeln( ' Recovering the Demo.Dbf... ');
With MyDb^ do
Begin
Recover(500) ; { 500 records are targetted }
Writeln(' 73 records will be guaranteed to be recovered on Hard Disk');
Writeln(' 146 record will be recovered on Hard disk with Stacker' );
Writeln(' Formula for calculation : TRUNC( Clusterbytes/Recsize ) ' );
Dispose( MyDb , done );
End;
Writeln;
Writeln(' Any Key Now..');
ch := Readkey
End;
Begin
Repeat
Clrscr ;
Writeln(' 1. Memory Allocation Test ' );
Writeln(' 2. Create Dbase Test');
Writeln(' 3. Data Append Test ' );
Writeln(' 4. Data Delete Test' );
Writeln(' 5. Pack Test ' );
Writeln(' 6. Zap Test ');
Writeln(' 7. Recover Test ');
Writeln(' 0. Exit the Tests ');
Writeln;
Write(' Select your Optio